home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-01 / cexpert.zip / MCH9.LST < prev   
File List  |  1990-09-15  |  8KB  |  479 lines
  1.    Listing 9-1  Sample Program to Read LISP Expressions
  2.  
  3. /*
  4. ** INPUT.C
  5. **
  6. **
  7. ** History:
  8. **
  9. ** Routines to read lists in lisp fashion, i.e. of the form
  10. ** s_expression ::= atom | ( list )
  11. ** list     ::= list atom |
  12. **
  13. */
  14.  
  15. #include <ctype.h>
  16. #include <stdio.h>
  17. #include "cons.h"
  18.  
  19. #define LEFT_PAREN  64
  20. #define RIGHT_PAREN 128
  21.  
  22. cons *lread(type,where)
  23. int type;
  24. char *where;
  25. {
  26.   int dummy;
  27.   cons *read_s_expr();
  28.  
  29.   return read_s_expr(type,where,&dummy);
  30. }
  31.  
  32. static cons *read_s_expr(type,where,etype)
  33. int  type,*etype;
  34. char *where;
  35. {
  36.   int          ty;
  37.   cons          *f,*read_list();
  38.   char          *strsave();
  39.   static char buf[512];
  40.  
  41.   switch (get_token(type,where,buf)) {
  42.     case 0:                /* empty list */
  43.     f = NULL;                /* return a NIL pointer */
  44.     break;
  45.  
  46.     case CAR_STRING:            /* a string */
  47.     if (f = mkcons(CAR_STRING,strsave(buf),NULL)) {
  48.       *etype = CAR_STRING;
  49.     }
  50.     break;
  51.  
  52.     case LEFT_PAREN:
  53.     f = read_list(type,where);
  54.     *etype = CAR_LIST;
  55.     break;
  56.  
  57.     case RIGHT_PAREN:
  58.     f = (cons *) 1;            /* for right parens */
  59.     *etype = ')';
  60.     break;
  61.   }
  62.   return f;
  63. }
  64.  
  65. cons *read_list(type,where)
  66. int type;
  67. char *where;
  68. {
  69.   cons *t, *z;
  70.   int         first = 0,etype;
  71.  
  72.   z = read_s_expr(type,where,&etype);
  73.   if (etype == ')') {
  74.     t = NULL;
  75.   } else {
  76.     if (t = mkcons(CAR_LIST,z,read_list(type,where))) {
  77.       return t;
  78.     } else {
  79.       t = NULL;
  80.     }
  81.   }
  82.   return t;
  83. }
  84.  
  85. int get_token(type,ip,store)
  86. int type;                /* file or string input */
  87. char *ip;                /* input source */
  88. char *store;                /* place to store strings */
  89. {
  90.   int  c;
  91.   char *s;
  92.  
  93.   c = skip_whitespace(type,ip);
  94.   if (c=='"') {
  95.     for (s=store;;s++) {
  96.       switch (*s = Getc(type,ip)) {
  97.     case '"':
  98.     if ((c = Getc(type,ip)) != '"') {
  99.       Ungetc(type,c,ip);
  100.       *s = '\0';
  101.       return CAR_STRING;
  102.     }
  103.     break;
  104.  
  105.     case '\\':
  106.     switch (c=Getc(type,ip)) {
  107.       case 'n':
  108.       *s = '\n';
  109.       break;
  110.  
  111.       case 'r':
  112.       *s = '\r';
  113.       break;
  114.  
  115.       case 'd':
  116.       *s = '\004';
  117.       break;
  118.  
  119. /*      case '0':
  120.       Ungetc(type,c,ip);
  121.       *s = (char) c;
  122.       break;
  123. */
  124.       case 'p':
  125.       *s++ = '\\';
  126.       *s   = 'p';
  127.       break;
  128.  
  129.       case '(':
  130.       *s++ = '\\';
  131.       *s   = '(';
  132.       break;
  133.  
  134.       case ')':
  135.       *s++ = '\\';
  136.       *s   = ')';
  137.       break;
  138.  
  139.       case '\0':
  140.       *s = '\0';
  141.       return CAR_STRING;
  142.       break;
  143.  
  144.       default:
  145.       *s = c;
  146.       break;
  147.     }
  148.     break;
  149.       }
  150.     }
  151.   }
  152.   if (isalpha(c) || c == '?') {
  153.     Ungetc(type,c,ip);
  154.     for (s=store; isalpha(*s=Getc(type,ip)) || isdigit(*s) || *s == '-'
  155.                         || *s == '?'; s++)
  156.       ;
  157.     Ungetc(type,*s,ip);
  158.     *s='\0';
  159.     return CAR_STRING;
  160.   }
  161.  
  162.   if (isdigit(c)) {
  163.     int n = c - '0';
  164. /*
  165.     while (c = Getc(type,ip),isdigit(c)) {
  166.       n *= 10;
  167.       n += c - '0';
  168.     }
  169.     Ungetc(type,c,ip);
  170.     *((int *) store) = n;
  171. */
  172.     *store++ = c;
  173.     while (c = Getc(type,ip),isdigit(c) || c == '.') {
  174.       *store++ = c;
  175.     }
  176.     *store = '\0';
  177.     Ungetc(type,c,ip);
  178.     return CAR_STRING;
  179.   }
  180.  
  181.   if (c == '(') {
  182.     if ((c = skip_whitespace(type,ip)) == ')') {
  183.       return 0;             /* empty list */
  184.     } else {
  185.       Ungetc(type,c,ip);
  186.       return LEFT_PAREN;
  187.     }
  188.   }
  189.   if (c == ')') {
  190.     return RIGHT_PAREN;
  191.   }
  192.   return c;
  193. }
  194.  
  195.  
  196.  
  197. char *strsave(s)
  198. char *s;
  199. {
  200.   char *t;
  201.  
  202.   if (t = (char *) malloc(strlen(s)+1)) {
  203.     strcpy(t,s);
  204.   }
  205.   return t;
  206. }
  207.  
  208.  
  209. int Getc(type,source)
  210. int type;
  211. char *source;
  212. {
  213.   if (type == C_STRING) {
  214.     return (*(*((char **) source))++);        /* whew! */
  215.   } else {
  216.     return getc((FILE *) source);
  217.   }
  218. }
  219.  
  220. int Ungetc(type,c,source)
  221. int type;
  222. char c;
  223. char *source;
  224. {
  225.   if (type == C_STRING) {
  226.     *--(*((char **) source)) = c;
  227.   } else {
  228.     ungetc(c,(FILE *) source);
  229.   }
  230. }
  231.  
  232.  
  233. int skip_whitespace(type,ip)
  234. int type;
  235. char *ip;
  236. {
  237.   int c;
  238.  
  239.   while ((c = Getc(type,ip)) == ' ' || c == '\t' || c == '\n' || c == ';')
  240.    if (c == ';')                        /* a comment */
  241.      while (Getc(type,ip) != '\n')      /* read up to & including the EOL */
  242.        ;
  243.   return c;
  244. }
  245.  
  246. Listing 9-2  Sample Program to Print Output in LISP Fashion
  247.  
  248. /*
  249. ** OUTPUT.C
  250. **
  251. **
  252. ** Routines to print lists in lisp fashion.
  253. **
  254. */
  255.  
  256. #include <stdio.h>
  257. #include "cons.h"
  258.  
  259. static int sputs(s,where)            /* similar to fputs */
  260. char *s, *where;
  261. {
  262.     strcat(where,s);
  263.     return 0;
  264. }
  265.  
  266. /****************/
  267.  
  268. lprint(l,type,target)
  269. cons *l;
  270. int  type;
  271. char *target;
  272. {
  273.   switch (type) {
  274.     case C_STRING:
  275.     _print_s_expr(l,sputs,target);
  276.     break;
  277.     
  278.     case C_FILE:
  279.     _print_s_expr(l,fputs,target);
  280.     break;
  281.     
  282.     default:
  283.     ; /**/ /* Error-message */
  284.     break;
  285.   }
  286. }
  287.  
  288. /************/
  289.  
  290. static _print_s_expr(node,output,target)
  291. cons *node;
  292. int (*output)();
  293. char *target;
  294. {
  295.     static char slask[80];
  296.     
  297.   if (node->type == 0 & node->car.p == NULL) {
  298.     printf("()");
  299.   } else if (node->type == CAR_STRING) {
  300.     (*output) ((char *) node->car.s,target);
  301.   } else if (node->type == CAR_LIST) {
  302.     _print_list(node,output,target);
  303.   } else {
  304.     ;    /**/ /* Error message */
  305.   }
  306. }
  307.  
  308.  
  309.  
  310.  
  311.  
  312. /*
  313. ** _print_list():
  314. */
  315.  
  316. static _print_list(node,output,target)
  317. cons *node;
  318. int (*output)();
  319. char *target;
  320. {
  321.   (*output) ("(",target);
  322.   do {
  323.     _print_s_expr((cons *) node->car.p,output,target);
  324.     node = node->cdr;
  325.     (*output) ((node == NULL) ? ")" : " ",target);
  326.   } while (node != NULL);
  327. }
  328.       Listing 9-3  Sample Program for Creating Windows
  329.  
  330. /*
  331. ** WINDOW.C
  332. ** 
  333. ** Supports a little window in the region (1,19) - (78,22) on the screen.
  334. ** Diagnostic output from REMOTE will be routed to this window. It is 
  335. ** deliberately very stupid, and will only accept <CR>, <LF> and <BS> as
  336. ** valid control characters. Everything else is output directly to the 
  337. ** screen in the region specified above.
  338. */
  339.  
  340. #include <dos.h>
  341.  
  342. #define LOX 1
  343. #define HIX 78
  344. #define LOY 19
  345. #define HIY 22
  346. #define WIN_COLOR 0x0E
  347. #define VIDEO 0x10
  348.  
  349. static int winx, winy,display_page;
  350.  
  351. wclear()
  352. {
  353.   union REGS in,out;
  354.  
  355.   in.h.ah = 0x0F;                /* get current video mode */
  356.   int86(VIDEO,&in,&out);
  357.   display_page = out.h.bh;        /* current screen */
  358.   out.h.ah = 0x02;                /* set cursor position */
  359.   out.h.bh = display_page;
  360.   out.h.dl = winx = LOX;            /* move to home position */
  361.   out.h.dh = winy = HIY;
  362.   int86(VIDEO,&out,&in);
  363. }
  364.    
  365.  
  366. /*
  367. ** wputs(): John's window puts: put string to window using BIOS services
  368. */
  369.  
  370. wputs(s)                     /* put string using BIOS IO */
  371. char *s;
  372. {
  373.   while (*s) {
  374.     wputc(*s++);      
  375.   }
  376. }
  377.  
  378. wputc(c)
  379. char c;
  380. {
  381.   union REGS regs;
  382.  
  383.   if (winy < LOY) {
  384.     winy = LOY;
  385.     winx = LOX;
  386.   }
  387.   regs.h.ah = 0x02;                /* set cursor position */
  388.   regs.h.bh = display_page;
  389.   regs.h.dl = winx;                /* move to home position */
  390.   regs.h.dh = winy;
  391.   int86(VIDEO,®s,®s);
  392.   switch (c) {
  393.     case '\b':
  394.     if (winx > LOX) 
  395.       --winx;
  396.     break;
  397.     
  398.     case '\r':
  399.     winx = LOX;
  400.     break;
  401.     
  402.     case '\n':
  403.     wnl();
  404.     break;
  405.     
  406.     default:
  407.     regs.h.ah = 0x09;                /* draw character */
  408.     regs.h.al = c;
  409.     regs.h.bl = WIN_COLOR;
  410.     regs.h.bh = display_page;
  411.     regs.x.cx = 1;                /* only 1 char */
  412.     int86(VIDEO,®s,®s);            /* dumpit */
  413.     if (++winx > HIX) {
  414.       winx = LOX;
  415.       wnl();
  416.     }
  417.   }
  418.   regs.h.ah = 0x02;                /* set cursor position */
  419.   regs.h.bh = display_page;
  420.   regs.h.dl = winx;                /* move to home position */
  421.   regs.h.dh = winy;
  422.   int86(VIDEO,®s,®s);
  423. }
  424.  
  425. wnl() {
  426.   union REGS in;
  427.   if (winy < HIY) {                /* not at bottom line */
  428.     ++winy;
  429.   } else {
  430.     winy = HIY;                    /* force to bottom line */
  431.     in.h.ah  = 0x06;                /* scroll window up */
  432.     in.h.bh  = display_page;            /* current screen */
  433.     in.h.al  = 1;                /* scroll one line */
  434.     in.h.cl  = LOX;                /* region. */
  435.     in.h.ch  = LOY;
  436.     in.h.dl  = HIX;
  437.     in.h.dh  = HIY;
  438.     in.h.bh  = WIN_COLOR;
  439.     int86(VIDEO,&in,&in);
  440.   }
  441. }
  442.  
  443.  
  444.  
  445.  
  446.  
  447.  
  448. Listing 9-4  Sample Program to Compute the Minimum Certainty
  449.  
  450. /*
  451. ** MIN.C
  452. **
  453. ***/
  454.  
  455. #include <stdio.h>
  456. #include "cons.h"
  457. #include "goal.h"
  458.  
  459.  
  460. /*-------------------------------------------------Min()-------------------*/
  461.  
  462. /*
  463. **    Get the minimum certaity between two.
  464. */
  465.  
  466. double Min(cert1,cert2,cert3)
  467. double cert1,cert2,*cert3;
  468. {
  469.     
  470.     if(cert1 <= cert2)
  471.     {
  472.         (*cert3) = cert1;
  473.     }
  474.     else 
  475.     {
  476.         (*cert3) = cert2;
  477.     }
  478. }
  479.